home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / extend / tclsrc / buildidx.tcl < prev    next >
Encoding:
Text File  |  1993-10-26  |  4.6 KB  |  139 lines  |  [TEXT/MPS ]
  1. #
  2. # buildidx.tcl --
  3. #
  4. # Code to build Tcl package library. Defines the proc `buildpackageindex'.
  5. # 
  6. #------------------------------------------------------------------------------
  7. # Copyright 1992-1993 Karl Lehenbauer and Mark Diekhans.
  8. #
  9. # Permission to use, copy, modify, and distribute this software and its
  10. # documentation for any purpose and without fee is hereby granted, provided
  11. # that the above copyright notice appear in all copies.  Karl Lehenbauer and
  12. # Mark Diekhans make no representations about the suitability of this
  13. # software for any purpose.  It is provided "as is" without express or
  14. # implied warranty.
  15. #------------------------------------------------------------------------------
  16. # $Id: buildidx.tcl,v 2.5 1993/07/20 08:35:45 markd Exp $
  17. #------------------------------------------------------------------------------
  18. #
  19.  
  20. #------------------------------------------------------------------------------
  21. # The following code passes around a array containing information about a
  22. # package.  The following fields are defined
  23. #
  24. #   o name - The name of the package.
  25. #   o offset - The byte offset of the package in the file.
  26. #   o procs - The list of entry point procedures defined for the package.
  27. #------------------------------------------------------------------------------
  28.  
  29. #------------------------------------------------------------------------------
  30. # Write a line to the index file describing the package.
  31. #
  32. proc TCLSH:PutIdxEntry {outfp pkgInfo endOffset} {
  33.     puts $outfp [concat [keylget pkgInfo name] \
  34.                         [keylget pkgInfo offset] \
  35.                         [expr {$endOffset - [keylget pkgInfo offset] - 1}] \
  36.                         [keylget pkgInfo procs]]
  37. }
  38.  
  39. #------------------------------------------------------------------------------
  40. # Parse a package header found by a scan match.  Handle backslashed
  41. # continuation lines.
  42. #
  43. proc TCLSH:ParsePkgHeader matchInfoVar {
  44.     upvar $matchInfoVar matchInfo
  45.  
  46.     set line [string trimright $matchInfo(line)]
  47.     while {[string match {*\\} $line]} {
  48.         set line [csubstr $line 0 [expr [clength $line]-1]]
  49.         append line " " [string trimright [gets $matchInfo(handle)]]
  50.     }
  51.  
  52.     keylset pkgInfo name   [lindex $line 1]
  53.     keylset pkgInfo offset [tell $matchInfo(handle)]
  54.     keylset pkgInfo procs  [lrange $line  2 end]
  55.     return $pkgInfo
  56. }
  57.  
  58. #------------------------------------------------------------------------------
  59. # Do the actual work of creating a package library index from a library file.
  60. #
  61. proc TCLSH:CreateLibIndex {libName} {
  62.  
  63.     if {[file extension $libName] != ".tlib"} {
  64.         error "Package library `$libName' does not have the extension `.tlib'"
  65.     }
  66.     set idxName "[file root $libName].tndx"
  67.  
  68.     unlink -nocomplain $idxName
  69.     set libFH [open $libName r]
  70.     set idxFH [open $idxName w]
  71.  
  72.     set contectHdl [scancontext create]
  73.  
  74.     scanmatch $contectHdl "^#@package: " {
  75.         if {[llength $matchInfo(line)] < 2} {
  76.             error "invalid package header \"$matchInfo(line)\""
  77.         }
  78.         if ![lempty $pkgInfo] {
  79.             TCLSH:PutIdxEntry $idxFH $pkgInfo $matchInfo(offset)
  80.         }
  81.         set pkgInfo [TCLSH:ParsePkgHeader matchInfo]
  82.     }
  83.  
  84.     scanmatch $contectHdl "^#@packend" {
  85.         if [lempty $pkgInfo] {
  86.             error "#@packend without #@package in $libName"
  87.         }
  88.         TCLSH:PutIdxEntry $idxFH $pkgDefName $pkgDefWhere $matchInfo(offset) \
  89.                           $pkgDefProcs
  90.         set pkgInfo {}
  91.     }
  92.  
  93.     set pkgInfo {}
  94.     if {[catch {
  95.         scanfile $contectHdl $libFH
  96.         if [lempty $pkgInfo] {
  97.             error "No #@package definitions found in $libName"
  98.         }   
  99.     } msg] != 0} {
  100.        global errorInfo errorCode
  101.        close $libFH
  102.        close $idxFH
  103.        unlink -nocomplain $idxName
  104.        error $msg $errorInfo $errorCode
  105.     }
  106.     if ![lempty $pkgInfo] {
  107.         TCLSH:PutIdxEntry $idxFH $pkgInfo [tell $libFH] 
  108.     }
  109.     close $libFH
  110.     close $idxFH
  111.     
  112.     scancontext delete $contectHdl
  113.  
  114.     # Set mode and ownership of the index to be the same as the library.
  115.     # Ignore errors if you can't set the ownership.
  116.  
  117.     file stat $libName statInfo
  118.     chmod $statInfo(mode) $idxName
  119.     catch {
  120.        chown [list $statInfo(uid) $statInfo(gid)] $idxName
  121.     }
  122. }
  123.  
  124. #------------------------------------------------------------------------------
  125. # Create a package library index from a library file.
  126. #
  127. proc buildpackageindex {libfile} {
  128.  
  129.     set status [catch {
  130.         TCLSH:CreateLibIndex $libfile
  131.     } errmsg]
  132.     if {$status != 0} {
  133.         global errorInfo errorCode
  134.         error "building package index for `$libfile' failed: $errmsg" \
  135.               $errorInfo $errorCode
  136.     }
  137. }
  138.  
  139.